home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / UTILITY / MAPPINGS.lisp < prev    next >
Encoding:
Text File  |  1990-06-25  |  9.3 KB  |  199 lines  |  [TEXT/MACA]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         MAPPINGS.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      16-Jun-88 09:28:29
  17. ; Modified:     22-Jun-90 02:06:44 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      UTILS
  20. ;
  21. ; Description:  Macros for treating association lists as abstract mappings.
  22. ;
  23. ; (c) Copyright 1988, by Daniel D. Suthers
  24. ;                        Department of Computer and Information Science
  25. ;                        University of Massachusetts
  26. ;                        Amherst, Massachusetts 01003
  27. ;
  28. ; This software was conceived, designed, and written by Dan Suthers 
  29. ; while supported by the National Science Foundation under grant number
  30. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  31. ; CA.  Partial support was also received from the Office of Naval Research
  32. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  33. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  34. ; the above grants and encouraged me to pursue my own research interests in
  35. ; her lab.  This work would not have been possible without the resources and
  36. ; stimulating environment of the Computer and Information Science department.
  37. ;
  38. ; Permission to use, modify, and distribute this software is granted subject 
  39. ; to the following restrictions and understandings:
  40. ; 1. The file header, including this notice, shall be retained, and may be
  41. ;    extended to include documentation of modifications to the software.
  42. ; 2. This material is for nonprofit educational and research purposes only.
  43. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  44. ;    noteworthy uses of this software.
  45. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  46. ;    representation that the operation of this software will be error free,
  47. ;    and are under no obligation to provide any services.
  48. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  49. ;    Suthers and the University of Massachusetts from all claims arising 
  50. ;    out of the use or misuse of this software, or arising out of any 
  51. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  52. ;    fees, and liabilities incurred in or about any such claim, action, or
  53. ;    proceeding brought thereon.
  54. ; 5. All materials and reports developed as a consequence of the use of 
  55. ;    this software shall duly acknowledge such use, in accordance with
  56. ;    the usual standards of acknowledging credit in academic research.
  57.  
  58. ; Status:       Done and tested.
  59. ;
  60. ; Changes:
  61. ;   22-Mar-89 Added COMPOSE-MAPPINGS.
  62. ;   30-Apr-90 Fixed bug in EXTEND-MAPPING; added MERGE-MAPPINGS.
  63. ;
  64. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65. ;
  66. ;  All mappings are assumed to be association lists where each item in the
  67. ;  image set appears only once in the CAR of a cons.  The CDR is the image
  68. ;  of that item under the mapping.  ADJOIN-TO-IMAGE and DELETE-FROM-IMAGE
  69. ;  assume that images are sets represented by lists; while the other macros
  70. ;  work with either list or atomic images.  Incremental extension and re-
  71. ;  striction of mappings is supported by EXTEND-MAPPING and RESTRICT-MAPPING.
  72. ;  The common-lisp ACONS and PAIRLIS may also be used to construct mappings.
  73. ;
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75.  
  76. (in-package :UTILS)
  77.  
  78. (export '(
  79.           adjoin-to-image
  80.           compose-mappings
  81.           delete-from-image
  82.           domain
  83.           extend-mapping
  84.           image
  85.           merge-mappings
  86.           preimage
  87.           range
  88.           restrict-mapping
  89.           ))
  90.  
  91. (defmacro ADJOIN-TO-IMAGE (item key mapping &key (test '#'eq))
  92.   "adjoin-to-image <item> <key> <mapping> &key :test       [Destructive Macro]
  93.   Given that <mapping> is setf-able access to an association list with
  94.   lists for images: ((k1 d11 ... d1n) ... (km dm1 ... dmp)); will adjoin
  95.   <item> to the image of <key>.  Creates an entry for <key> if it is not
  96.   already one of the ki.  Test defaults #'eq. <Mapping> shouldn't have side 
  97.   effects."
  98.   `(let ((the-key   ,key)
  99.          (the-item  ,item))
  100.      (if ,mapping
  101.        (let ((key+image (assoc the-key ,mapping :test ,test)))
  102.          (if key+image
  103.            (pushnew the-item (rest key+image) :test ,test)
  104.            (push (list the-key the-item) ,mapping)))
  105.        (setf ,mapping (list (list the-key the-item))))
  106.      the-item))
  107.  
  108. (defmacro COMPOSE-MAPPINGS (map1 map2)
  109.   "compose-mappings <map1> <map2>                                      [Macro]
  110.   Returns a new mapping (freshly consed at the top level but possibly reusing
  111.   components) in which the images of <map1> have been replaced by their images
  112.   in <map2>.  Key and image pairs in <map1> not having images in <map2> are 
  113.   copied into the composed mapping unmodified."
  114.   `(let ((substitution-map ,map2))
  115.      (declare (list substitution-map))
  116.      (mapcar #'(lambda (key1+image)
  117.                  (declare (cons key1+image))
  118.                  (let ((key2+image (assoc (cdr key1+image) substitution-map)))
  119.                    (if key2+image
  120.                      (cons (car key1+image) (cdr key2+image))
  121.                      key1+image)))
  122.              ,map1)))
  123.  
  124. (defmacro DELETE-FROM-IMAGE (item key mapping &key (test '#'eq))
  125.   "delete-from-image <item> <key> <mapping> &key :test     [Destructive Macro]
  126.   Given that <mapping> is setf-able access to an association list with
  127.   lists for images: ((k1 d11 ... d1n) ... (km dm1 ... dmp)); will delete
  128.   <item> from the image of <key>.  Does nothing if <key> is not found.
  129.   Test defaults #'eq.  <Mapping> shouldn't have side effects."
  130.   `(let* ((the-key   ,key)
  131.           (the-item  ,item)
  132.           (key+image (assoc the-key ,mapping :test ,test)))
  133.      (if key+image
  134.        (setf (cdr key+image)
  135.              (delete the-item (cdr key+image) :test ,test)))
  136.      the-item))
  137.  
  138. (defmacro DOMAIN (mapping)
  139.   "domain <mapping>                                                    [Macro]
  140.   Returns a (freshly constructed) list representing the domain of the 
  141.   mapping represented by the alist <mapping>."
  142.   `(mapcar #'car ,mapping))
  143.  
  144. (defmacro EXTEND-MAPPING (element image mapping)
  145.   "extend-mapping <element> <image> <mapping> &key :test   [Destructive Macro]
  146.   Extends the <mapping> to include <element> and its <image>.  The place
  147.   which <mapping> evaluates to is modified.  Assumes <element> is not 
  148.   already there."
  149.   `(push (cons ,element ,image) ,mapping))
  150.  
  151. (defmacro IMAGE (key mapping &key (test '#'eq))
  152.   "image <key> <mapping> &key :test                                    [Macro]
  153.   Returns the image of <key> under the mapping represented by the alist 
  154.   <mapping>. Assumes the mapping is 1-1.  Setf accessible. The test defaults
  155.   to #'eq."
  156.   `(cdr (assoc ,key ,mapping :test ,test)))
  157.  
  158. (defmacro MERGE-MAPPINGS (map1 map2 &key (test '#'eq))
  159.   "merge-mappings <map1> <map2> &key test
  160.   Returns a freshly constructed mapping which has all keys of the two
  161.   mappings with the union of their respective images.  (For efficiency,
  162.   give <map1> the longer list.)  Test defaults #'eq."
  163.   `(let ((new-mapping (copy-alist ,map1)))
  164.      (declare (list new-mapping))
  165.      (dolist (key+image2 ,map2)
  166.        (declare (cons key+image2))
  167.        (let ((key+image1 (assoc (car key+image2) new-mapping :test ,test)))
  168.          (if key+image1
  169.            (setf (cdr key+image1) (union (cdr key+image1) (cdr key+image2)))
  170.            (push (copy-list key+image2) new-mapping))))
  171.      new-mapping))
  172.  
  173. (defmacro PREIMAGE (image mapping &key (test '#'eq))
  174.   "preimage <image> <mapping> &key :test                               [Macro]
  175.   Returns the preimage of <image> under the mapping represented by the
  176.   alist <mapping>. Assumes the inverse of the mapping is 1-1. Setf 
  177.   accessible. The test defaults to #'eq."
  178.   `(car (rassoc ,image ,mapping :test ,test)))
  179.  
  180. (defmacro RANGE (mapping)
  181.   "range <mapping>                                                     [Macro]
  182.   Returns a (freshly constructed) list representing the range of the
  183.   mapping represented by the alist <mapping>."
  184.   `(mapcar #'cdr ,mapping))
  185.  
  186. (defmacro RESTRICT-MAPPING (element mapping &key (test '#'eq))
  187.   "restrict-mapping <element> <mapping> &key :test         [Destructive Macro]
  188.                  
  189.   Restricts the <mapping> by eliminating <element>.  The place which 
  190.   <mapping> evaluates to is modified. Its evaluation should not have
  191.   side effects.  Test defaults #'EQ."
  192.   `(setf ,mapping
  193.          (delete ,element ,mapping :key #'car :test ,test)))
  194.  
  195. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  196. (provide :MAPPINGS)
  197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  198. ;;; EOF
  199.